home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
The World of Computer Software.iso
/
faq-s.zip
/
INIT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-04
|
16KB
|
664 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65500,0,0 }
{$DEFINE OVERLAY}
unit init;
interface
uses crt,dos,filexfer,
gentypes,modem,statret,configrt,gensubs,subs1,windows,subs2;
procedure validconfiguration;
procedure initboard (checkfiles30:boolean);
implementation
procedure validconfiguration;
var errs:integer;
cnt:integer;
flag:boolean;
procedure error (q:anystr);
begin
if errs=0 then writeln (usr,'Setup Errors:');
errs:=errs+1;
writeln (usr,errs,'. ',q)
end;
procedure ispath (var x:lstr; name:lstr);
begin
if not exist(x+'con') then begin
writeln (usr,'Path bad: '+x+' - Creating.');
mkdir (copy(x,1,length(x)-1))
end;
end;
procedure isfilename (var xx:lstr; fn:lstr);
begin
if not exist(xx) then error (fn+' Filename bad: '+xx)
end;
procedure isstring (x:anystr; name:lstr);
var cnt:integer;
begin
if length(x)=0 then begin
error (name+' has not been set!');
exit
end;
for cnt:=1 to length(x) do if not (x[cnt] in [#32..#255])
then begin
error ('Bad '+name+' string');
exit
end
end;
procedure isinteger (n,r1,r2:integer; name:lstr);
begin
if (n<r1) or (n>r2) then error ('Bad '+name+' value: '+strr(n));
end;
procedure islongint (n,r1,r2:longint; name:lstr);
begin
if (n<r1) or (n>r2) then error ('Bad '+name+' value: '+strr(n));
end;
procedure dothat (name:lstr);
begin
if not exist (faqdir+name) then begin errs:=errs+1;
writeln (usr,errs,'. '+name+' does not exist!'); end;
end;
begin
errs:=0;
ispath (textdir,'Path to Message Base');
ispath (uploaddir,'Path to Ascii Uploads');
ispath (datadir,'Path to Xfer and Data Files');
ispath (textfiledir,'Path to Menus, etc.');
ispath (doordir,'Path to DOOR Batch Files');
ispath (networkdir,'Path to Network Files');
ispath (bbsdatadir,'Path to BBS Data Files');
ispath (xferdir,'Path to Xfer Uploads');
isstring (sysopname,'Sysop Name');
islongint (defbaudrate,300,38400,'default Baud Rate');
isinteger (usecom,1,4,'COM Port');
isinteger (mintimeout,1,maxint,'input time out');
isinteger (sysoplevel,1,maxint,'Co-Sysop Level');
if (not exist (faqdir+'DSZ.COM')) and (not exist (faqdir+'DSZ.EXE')) then begin
errs:=errs+1; writeln (usr,errs,'. DSZ.COM and DSZ.EXE do not exist!'); end;
dothat ('PKZIP.EXE');
dothat ('PKUNZIP.EXE');
if (sblaster) and not (exist (faqdir+'VPLAY.EXE')) then begin errs:=errs+1;
writeln (usr,errs,'. VPLAY.EXE does not exist!'); end;
if not exist (faqdir+'REGISTER.DAT') then begin errs:=errs+1;
writeln (usr,errs,'. REGISTER.DAT does not exist!');
end else begin
assign (regsfile,faqdir+'REGISTER.DAT');
reset (regsfile);
seek (regsfile,0);
read (regsfile,reg);
if (not match(sysopname,reg.handle)) then begin errs:=errs+1; writeln (usr,errs,'. Not Registered to Sysop!'); end;
end;
flag:=true;
for cnt:=1 to 100 do if flag and (usertime[cnt]<1) then begin
flag:=false;
error ('Time per day has non-positive entries')
end;
if errs>0 then begin
halt (e_badconfig);
end;
end;
procedure initboard (checkfiles30:boolean);
procedure formatmfile;
var m:mailrec;
begin
rewrite (mfile);
fillchar (m,sizeof(m),255);
write (mfile,m)
end;
procedure openmfile;
var i:integer;
begin
i:=ioresult;
assign (mfile,bbsdatadir+'Mail.dat');
close (mfile);
reset (mfile);
i:=ioresult;
if i<>0
then if i=2
then formatmfile
else begin
writeln (usr,'Fatal error: Unable to open mail file!');
halt (e_fatalfileerror)
end
end;
procedure closetfile;
var n:integer;
begin
close (tfile);
n:=ioresult;
close (mapfile);
n:=ioresult
end;
procedure formattfile;
var cnt,p:integer;
r:real;
buff:buffer;
x:string[1];
const dummystr:sstr='Blank!! ';
begin
rewrite (mapfile);
if ioresult<>0 then begin
writeln (usr,'Unable to create Message Base.');
halt (e_fatalfileerror)
end;
p:=-2;
for cnt:=0 to numsectors do write (mapfile,p);
p:=1;
for cnt:=1 to sectorsize do begin
buff[cnt]:=dummystr[p];
p:=p+1;
if p>length(dummystr) then p:=1
end;
rewrite (tfile);
if ioresult<>0 then begin
writeln (usr,'Unable to create Message Base.');
halt (e_fatalfileerror)
end;
for cnt:=0 to 5 do write (tfile,buff)
end;
procedure opentfile;
var i,j:integer;
begin
assign (tfile,textdir+'Text');
assign (mapfile,textdir+'BlockMap');
closetfile;
reset (tfile);
i:=ioresult;
reset (mapfile);
j:=ioresult;
if (i<>0) or (j<>0) then formattfile;
firstfree:=-1
end;
procedure openufile;
var u:userrec;
n,cnt:integer;
procedure createuhfile;
var cnt:integer;
begin
rewrite (uhfile);
if ioresult<>0 then begin
writeln (usr,'Unable to create the User Index File, run FAQ Again.');
halt (e_fatalfileerror)
end;
seek (ufile,0);
while not eof(ufile) do begin
read (ufile,u);
write (uhfile,u.handle)
end
end;
begin
assign (ufile,bbsdatadir+'Users.Dat');
close (ufile);
reset (ufile);
n:=ioresult;
if n=0 then begin
numusers:=filesize(ufile)-1;
assign (uhfile,bbsdatadir+'UserIndx.Dat');
close (uhfile);
reset (uhfile);
if ioresult<>0
then createuhfile
else if filesize(uhfile)<>filesize(ufile) then begin
close (uhfile);
createuhfile
end;
exit
end;
close (ufile);
n:=ioresult;
rewrite (ufile);
fillchar (u,sizeof(u),0);
write (ufile,u);
u.handle:=sysopname;
u.defproto:='Z';
u.note:='SysOp';
u.realname:='';
u.sex:='';
u.age:=0;
u.citystate:='';
u.country:='';
u.zipcode:='';
if length(confm[1])>0 then u.defcon[1]:=true;
if length(confm[2])>0 then u.defcon[2]:=true;
if length(confm[3])>0 then u.defcon[3]:=true;
if length(confm[4])>0 then u.defcon[4]:=true;
if length(confm[5])>0 then u.defcon[5]:=true;
if length(confx[1])>0 then u.defcon[6]:=true;
if length(confx[2])>0 then u.defcon[7]:=true;
if length(confx[3])>0 then u.defcon[8]:=true;
if length(confx[4])>0 then u.defcon[9]:=true;
if length(confx[5])>0 then u.defcon[10]:=true;
u.macro1:=u.handle;
u.macro2:=longname;
u.macro3:='';
u.password:='FAQ';
u.phonenum:='1234567890';
u.timetoday:=1000;
u.level:=sysoplevel+1;
u.udlevel:=sysoplevel+1;
u.udpoints:=sysoplevel+1;
u.gflevel:=sysoplevel+1;
u.laston:=now;
u.config:=[lowercase,eightycols,linefeeds,postprompts,asciigraphics,ansigraphics,showtime];
u.emailannounce:=-1;
u.infoform1:=-1;
u.infoform2:=-1;
u.infoform3:=-1;
u.infoform4:=-1;
u.infoform5:=-1;
u.displaylen:=25;
u.regularcolor:=defcolor2;
u.statcolor:=defcolor3;
u.inputcolor:=defcolor4;
u.promptcolor:=defcolor1;
u.bordercolor:=defcolor5;
u.bstatuscolor:=defcolor6;
u.menutype:=0;
u.laston:=now;
fillchar (u.access2,32,255);
if useconmode then u.config:=u.config+[ansigraphics,fseditor];
write (ufile,u);
numusers:=1;
createuhfile
end;
procedure initfile (var f:file);
var fi:fib absolute f;
begin
fi.handle:=0;
fi.name[0]:=chr(0)
end;
procedure openlogfile;
procedure autodeletesyslog;
var mx,cnt:integer;
l:logrec;
begin
dontanswer;
write (usr,'Auto-deleting System Log - please stand by.');
mx:=filesize(logfile) div 2;
for cnt:=1 to mx do begin
seek (logfile,cnt+mx-1);
read (logfile,l);
seek (logfile,cnt-1);
write (logfile,l)
end;
seek (logfile,mx-1);
truncate (logfile);
writeln (usr,'Done.');
doanswer
end;
begin
assign (logfile,bbsdatadir+'Syslog.dat');
close (logfile);
reset (logfile);
if ioresult<>0 then begin
rewrite (logfile);
if ioresult<>0 then begin
writeln (usr,'Unable to create log file');
halt (e_fatalfileerror)
end
end;
if filesize(logfile)>maxsyslogsize then autodeletesyslog
end;
procedure loadsyslogdat;
var tf:text;
q:lstr;
b1,b2,p,s,n:integer;
begin
numsyslogdat:=0;
with syslogdat[0] do begin
menu:=0;
subcommand:=0;
text:='Entry Not Found: %'
end;
assign (tf,'syslog.faq');
reset (tf);
if ioresult=0 then begin
while not eof(tf) do begin
readln (tf,q);
p:=pos(' ',q);
if p<>0 then begin
val (copy(q,1,p-1),b1,s);
if s=0 then begin
delete (q,1,p);
p:=pos(' ',q);
if p<>0 then begin
val (copy(q,1,p-1),b2,s);
if s=0 then begin
delete (q,1,p);
if numsyslogdat=maxsyslogdat
then writeln (usr,'Too many SYSLOG.FAQ entries')
else begin
numsyslogdat:=numsyslogdat+1;
with syslogdat[numsyslogdat] do begin
menu:=b1;
subcommand:=b2;
text:=copy(q,1,30)
end
end
end
end
end
end
end;
textclose (tf)
end;
if numsyslogdat=0 then writeln (usr,'SYSLOG.FAQ file missing or invalid')
end;
procedure doesfilesequal30;
var f:array [1..14] of file;
cnt,i:integer;
begin
{$IFNDEF OVERLAY}
for cnt:=1 to 14 do begin
assign (f[cnt],'CON');
reset (f[cnt]);
i:=ioresult;
if i<>0 then begin
writeln (usr,^M^G^J'ERROR: FILES=30 must be placed in your CONFIG.SYS');
halt (e_files40)
end
end;
for cnt:=14 downto 1 do close(f[cnt])
{$ENDIF}
end;
procedure readsysopmacros;
var ff:text;
ummbobway,killer:integer;
begin
assign (ff,faqdir+'SYSOP.MAC');
ummbobway:=0;
if not exist (faqdir+'SYSOP.MAC') then begin
sysopmacro1:=sysopname;
sysopmacro2:=longname;
sysopmacro3:='Sysop Macro #3';
sysopmacro4:='Sysop Macro #4';
sysopmacro5:='Sysop Macro #5';
sysopmacro6:='Sysop Macro #6';
sysopmacro7:='Sysop Macro #7';
sysopmacro8:='Sysop Macro #8';
sysopmacro9:='Sysop Macro #9';
sysopmacro10:='Sysop Macro #10';
end else
if exist (faqdir+'SYSOP.MAC') then begin
reset (ff);
readln (ff,sysopmacro1);
readln (ff,sysopmacro2);
readln (ff,sysopmacro3);
readln (ff,sysopmacro4);
readln (ff,sysopmacro5);
readln (ff,sysopmacro6);
readln (ff,sysopmacro7);
readln (ff,sysopmacro8);
readln (ff,sysopmacro9);
readln (ff,sysopmacro10);
close (ff);
end
end;
procedure faq;
procedure faqone;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(15);
gotoxy(20,1+i);write(usr,' ──────────────────── ');
gotoxy(20,2+i);clreol;
delay(10);
end;
end;
procedure faqtwo;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(1);
gotoxy(27,2+i);write(usr,'██████');
gotoxy(27,3+i);write(usr,'██ ');
gotoxy(27,4+i);write(usr,'██ ');
gotoxy(27,5+i);write(usr,'████ ');
gotoxy(27,6+i);write(usr,'██ ');
gotoxy(27,7+i);write(usr,'██ ');
gotoxy(27,8+i);write(usr,'██ ');
gotoxy(27,9+i);clreol;
delay(10);
end;
end;
procedure faqthree;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(9);
gotoxy(34,2+i);write(usr,' ████ ');
gotoxy(34,3+i);write(usr,'██ ██');
gotoxy(34,4+i);write(usr,'██ ██');
gotoxy(34,5+i);write(usr,'██ ██');
gotoxy(34,6+i);write(usr,'██ ██');
gotoxy(34,7+i);write(usr,'██████');
gotoxy(34,8+i);write(usr,'██ ██');
gotoxy(34,9+i);clreol;
delay(10);
end;
end;
procedure faqfour;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(11);
gotoxy(41,2+i);write(usr,' ████ ');
gotoxy(41,3+i);write(usr,'██ ██');
gotoxy(41,4+i);write(usr,'██ ██');
gotoxy(41,5+i);write(usr,'██ ██');
gotoxy(41,6+i);write(usr,'██ ▀█');
gotoxy(41,7+i);write(usr,'██ █▄ ');
gotoxy(41,8+i);write(usr,' ███▀█');
gotoxy(41,9+i);clreol;
delay(10);
end;
end;
procedure faqfive;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(15);
gotoxy(20,9+i);write(usr,' ──────────────────── ');
gotoxy(20,10+i);clreol;
delay(10);
end;
end;
procedure faqsix;
var
i:integer;
begin
for i:=21 downto 0 do begin
textcolor(11);
gotoxy(27,10+i);write(usr,' by The Firegod ');
gotoxy(27,11+i);clreol;
gotoxy(27,11+i+1);clreol;
delay(20);
end;
end;
begin
faqone;
faqtwo;
faqthree;
faqfour;
faqfive;
faqsix;
end;
var k,klux:char;
cnt:integer;
result:word;
begin
with textrec(system.output) do begin
openfunc:=@opendevice;
closefunc:=@closedevice;
flushfunc:=@writechars;
inoutfunc:=@writechars
end;
with textrec(system.input) do begin
inoutfunc:=@readcharfunc;
openfunc:=@ignorecommand;
closefunc:=@ignorecommand;
flushfunc:=@ignorecommand
end;
if checkfiles30 then doesfilesequal30;
fillchar (urec,sizeof(urec),0);
urec.config:=[lowercase,eightycols,asciigraphics,ansigraphics];
iocode:=0;
linecount:=0;
sysopavail:=bytime;
errorparam:='';
errorproc:='';
unam:='';
chainstr:='';
chatreason:='';
sendstr:='';
ulvl:=0;
unum:=-1;
logonunum:=-2;
echoit:=true;
break:=false;
atmenu:=false; { if you're at a menu or not }
nochain:=false; { doesn't continue with other write's etc.. }
nobreak:=true; { false before... }
wordwrap:=false; { does the wrapping of words to the next line }
beginwithspacesok:=false;
echodot:=false;
online:=false;
local:=true;
chatmode:=false;
texttrap:=false;
printerecho:=false;
fillchar (urec,sizeof(urec),0);
usecapsonly:=false;
uselinefeeds:=true;
curattrib:=0;
buflen:=80;
baudrate:=defbaudrate;
parity:=false;
statusbar:=false;
timelock:=false;
ingetstr:=false;
modeminlock:=false;
modemoutlock:=false;
tempsysop:=false;
sysnext:=false;
forcehangup:=false;
requestbreak:=false;
disconnected:=false;
bsent:=0; brecv:=0;
notitle:=false;
nosendprompt:=false;
emailing:=false;
periods:=false;
validprotos:=['X','Y','Z','J','L','G','O','1','S','K','R','P','W','4'];
cursection:=mainsysop;
regularlevel:=0;
if paramcount=1 then usecom:=2;
setparam (usecom,baudrate,parity);
doanswer;
initwinds;
for cnt:=1 to numsysfiles do initfile (sysfiles[cnt]);
window (1,1,80,25);
cursor (false);
clrscr;
for cnt:=1 to 25 do begin
gotoxy (1,cnt);
clreol;
end;
gotoxy (1,1);
cursor (true);
loadsyslogdat;
readstatus;
openufile;
opentfile;
openlogfile;
openmfile;
readsysopmacros;
end;
procedure assignname (var t:text; nm:lstr);
begin
with textrec(t) do begin
move (nm[1],name,length(nm));
name[length(nm)]:=#0
end
end;
var r:registers;
begin
checkbreak:=false;
checkeof:=false;
directvideo:=directvideomode;
checksnow:=checksnowmode;
r.ah:=15;
intr ($10,r);
if r.al=7
then screenseg:=$b000
else screenseg:=$b800;
textrec(system.input).mode:=fminput;
move (output,usr,sizeof(text)); { Set up device drivers }
move (output,direct,sizeof(text));
move (system.input,directin,sizeof(text));
with textrec(direct) do begin
openfunc:=@opendevice;
closefunc:=@closedevice;
flushfunc:=@directoutchars;
inoutfunc:=@directoutchars;
bufptr:=@buffer
end;
with textrec(directin) do begin
mode:=fminput;
inoutfunc:=@directinchars;
openfunc:=@ignorecommand;
flushfunc:=@ignorecommand;
closefunc:=@ignorecommand;
bufptr:=@buffer
end;
with textrec(usr) do bufptr:=@buffer;
assignname (usr,'USR');
assignname (direct,'DIRECT');
assignname (directin,'DIRECT-IN');
assignname (system.output,'OUTPUT');
assignname (system.input,'INPUT')
end.